home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
bmpclp.zip
/
BMPCLIP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-02-05
|
15KB
|
468 lines
{$A+,B-,D+,F-,G-,I+,L+,N-,R-,S+,V+,W+,X+}
{$M 8192,8192}
{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Demo program }
{ Copyright (c) 1991 by Borland International }
{ }
{************************************************}
{ This is an adaptation of the demo program BSCRLAPP.PAS included
with Turbo Pascal for Windows. The changes to this program allow
a 256 color bitmap to be displayed with the appropriate colors.
Further modifications were made to the program allowing the user to
copy the visible area of the bitmap to the Clipboard with the Copy
command added to the File menu. The code for this is contained in
the procedure CMCopyBmp. Resource file BMPCLIP.RES is the original
BSCRLAPP.RES file with the Copy command added to the menu with a
return value of 205. }
{*Modifications to enable the display of 256 color bitmaps by
Pat Ritchey (CIS:[70007,4660]) are marked with (!!) }
{*Code added to implement copy method by Scott Hanrahan
(CIS:[70144, 3033]) is marked with (*). }
program BMPCLIP;
{$R BMPCLIP.RES}
uses WinTypes, WinProcs, WinDos, WObjects, StdDlgs, Strings;
const
bsa_Name = 'BitmapScroll';
cm_Copy = 205; {*}
type
{ TBitScrollApp, a TApplication descendant }
TBitScrollApp = object(TApplication)
procedure InitMainWindow; virtual;
end;
{ TBitScrollWindow, a TWindow descendant }
PScrollWindow = ^TBitScrollWindow;
TBitScrollWindow = object(TWindow)
FileName: array[0..fsPathName] of Char;
BitmapHandle: HBitmap;
IconizedBits: HBitmap;
hPal : hPalette; {!!}
IconImageValid: Boolean;
PixelHeight, PixelWidth: Word;
Mode: Longint;
constructor Init(ATitle: PChar);
destructor Done; virtual;
function GetClassName : PChar; virtual;
procedure GetWindowClass(var WndClass: TWndClass); virtual;
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure CMFileOpen(var Msg: TMessage); virtual cm_First + cm_FileOpen;
procedure CMCopyBmp(var Msg: TMessage); virtual cm_First + cm_Copy; {*}
procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
procedure AdjustScroller;
function LoadBitmapFile(Name: PChar): Boolean;
Procedure CopyDIBPalette(var bmi : TBitMapInfo); {!!}
function OpenDIB(var TheFile: File): Boolean;
procedure GetBitmapData(var TheFile: File;
BitsHandle: THandle; BitsByteSize: Longint);
end;
{ __ahIncr, ordinal 114, is a 'magic' function. Defining this
function causes Windows to patch the value into the passed
reference. This makes it a type of global variable. To use
the value of AHIncr, use Ofs(AHIncr). }
procedure AHIncr; far; external 'KERNEL' index 114;
{ Construct the TBitScrollApp's MainWindow of type TBitScrollWindow }
procedure TBitScrollApp.InitMainWindow;
begin
MainWindow := New(PScrollWindow, Init(bsa_name));
end;
{ Constructor for a TBitScrollWindow, sets scroll styles and constructs
the Scroller object. Also sets the Mode based on whether the display
is monochrome (two-color) or polychrome. }
constructor TBitScrollWindow.Init(ATitle: PChar);
var
DCHandle: HDC;
begin
TWindow.Init(nil, ATitle);
Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
Attr.Menu := LoadMenu(HInstance, bsa_Name);
EnableMenuItem(Attr.Menu, cm_Copy, mf_ByCommand or mf_Grayed); {*}
BitmapHandle := 0;
hPal := 0; {!!}
IconImageValid := False;
Scroller := New(PScroller, Init(@Self, 1, 1, 200, 200));
DCHandle := CreateDC('Display', nil, nil, nil);
IconizedBits := CreateCompatibleBitmap(DCHandle, 64, 64);
if GetDeviceCaps(DCHandle, numColors) < 3 then Mode := notSrcCopy
else Mode := srcCopy;
DeleteDC(DCHandle);
end;
{ Change the class name to the application name. }
function TBitScrollWindow.GetClassName : PChar;
begin
GetClassName := bsa_Name;
end;
{ Allow the iconic picture to be drawn from the client area. }
procedure TBitScrollWindow.GetWindowClass(var WndClass: TWndClass);
begin
TWindow.GetWindowClass(WndClass);
WndClass.hIcon := 0; { Client area will be painted by the app. }
end;
destructor TBitScrollWindow.Done;
begin
if hPal <> 0 then DeleteObject(hPal); {!!}
hPal := 0; {!!}
if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
TWindow.Done;
end;
{ If the the 'Open...' menu item is selected, then, using
the current TFileDlgRec we prompt the user for a new bitmap
file. If the user selects one and it is one that we can
read, we display it in the window and change the window's
caption to reflect the new bitmap file. It should be noted
that we save the old TFileDlgRec just in case we are unable
to display the bitmap. This allows us to restore the old
search criteria. }
procedure TBitScrollWindow.CMFileOpen(var Msg: TMessage);
var
TempName: array[0..fsPathName] of Char;
CaptionBuffer: array [0..fsPathName+12{bsa_Name} +2{': '} +1{#0}] of Char;
begin
if Application^.ExecDialog(New(PFileDialog,
Init(@Self, PChar(sd_FileOpen), StrCopy(TempName, '*.bmp')))) = id_Ok then
if LoadBitmapFile(TempName) then
begin
StrCopy(FileName, TempName);
StrCopy(CaptionBuffer, bsa_Name);
StrCat(CaptionBuffer, ': ');
StrCat(CaptionBuffer, AnsiLower(FileName));
SetWindowText(HWindow, CaptionBuffer);
EnableMenuItem(Attr.Menu, cm_Copy, mf_ByCommand or mf_Enabled); {*}
end;
end;
procedure TBitScrollWindow.CMCopyBmp(var Msg: TMessage); {*}
var
R: TRect;
DC, MemDC1: HDC;
OldBitmap1, NewBmp: HBitmap;
OldCursor: HCursor;
NWidth, NHeight : LongInt;
begin
if BitmapHandle <> 0 then
begin
DC := GetDC(HWindow);
MemDC1 := CreateCompatibleDC(DC);
GetClientRect(HWindow, R);
NWidth := R.Right;
NHeight := R.Bottom;
NewBmp := CreateCompatibleBitmap(DC, NWidth, NHeight);
OldBitmap1 := SelectObject(MemDC1, NewBmp);
if NewBmp = 0 then
begin
MessageBox(HWindow, 'Unable to copy Bitmap', 'Error',
mb_IconExclamation or mb_ok);
SelectObject(MemDC1, OldBitmap1);
DeleteDC(MemDC1);
ReleaseDC(HWindow,DC)
end
else begin
OldCursor := SetCursor(LoadCursor(0, idc_Wait));
BitBlt(MemDC1, 0, 0, NWidth, NHeight, DC, 0, 0,
Mode);
OpenClipboard(HWindow);
EmptyClipboard;
SetClipboardData(cf_Bitmap, NewBmp);
CloseClipboard;
SetCursor(OldCursor);
SelectObject(MemDC1, OldBitmap1);
DeleteDC(MemDC1);
ReleaseDC(HWindow,DC)
end
end;
end;
{ Adjust the Scroller range so that the the origin is the
upper-most scrollable point and the corner is the
bottom-most. }
procedure TBitScrollWindow.AdjustScroller;
var
ClientRect: TRect;
begin
GetClientRect(HWindow, ClientRect);
with ClientRect do
Scroller^.SetRange(PixelWidth - (right - left),
PixelHeight - (bottom - top));
Scroller^.ScrollTo(0, 0);
InvalidateRect(HWindow, nil, True);
end;
{ Reset scroller range. }
procedure TBitScrollWindow.WMSize(var Msg: TMessage);
var
ClientRect: TRect;
DC, MemDC1, MemDC2: HDC;
OldBitmap1, OldBitmap2: HBitmap;
OldCursor: HCursor;
begin
TWindow.WMSize(Msg);
Scroller^.AutoOrg := not (Msg.wParam = sizeIconic);
if not (Msg.WParam = sizeIconic) then AdjustScroller
else if not IconImageValid and (BitmapHandle <> 0) then
begin
DC := GetDC(HWindow);
MemDC1 := CreateCompatibleDC(DC);
MemDC2 := CreateCompatibleDC(DC);
ReleaseDC(HWindow, DC);
OldBitmap1 := SelectObject(MemDC1, IconizedBits);
OldBitmap2 := SelectObject(MemDC2, BitmapHandle);
OldCursor := SetCursor(LoadCursor(0, idc_Wait));
StretchBlt(MemDC1, 0, 0, Msg.lParamLo, Msg.lParamHi, MemDC2,
0, 0, PixelWidth, PixelHeight, SrcCopy);
SetCursor(OldCursor);
SelectObject(MemDC1, OldBitmap1);
SelectObject(MemDC2, OldBitmap2);
DeleteDC(MemDC1);
DeleteDC(MemDC2);
IconImageValid := True;
end;
end;
{ Copys the bitmap bit data from the file into memory. Since
copying cannot cross a segment (64K) boundary, we are forced
to do segment arithmetic to compute the next segment. Created
a LongType type to simplify the process. }
procedure TBitScrollWindow.GetBitmapData(var TheFile: File;
BitsHandle: THandle; BitsByteSize: Longint);
type
LongType = record
case Word of
0: (Ptr: Pointer);
1: (Long: Longint);
2: (Lo: Word;
Hi: Word);
end;
var
Count: Longint;
Start, ToAddr, Bits: LongType;
begin
Start.Long := 0;
Bits.Ptr := GlobalLock(BitsHandle);
Count := BitsByteSize - Start.Long;
while Count > 0 do
begin
ToAddr.Hi := Bits.Hi + (Start.Hi * Ofs(AHIncr));
ToAddr.Lo := Start.Lo;
if Count > $4000 then Count := $4000;
BlockRead(TheFile, ToAddr.Ptr^, Count);
Start.Long := Start.Long + Count;
Count := BitsByteSize - Start.Long;
end;
GlobalUnlock(BitsHandle);
end;
Procedure TBitScrollWindow.CopyDIBPalette(var bmi : TBitMapInfo); {!!}
var
LogPal : PLogPalette;
i : integer;
PalSize : integer;
sz : word;
begin
if hPal <> 0 then {get rid of palette from previous bitmap }
begin
DeleteObject(hPal);
hPal := 0;
end;
PalSize := 1 shl bmi.bmiHeader.biBitCount;
sz := Sizeof(TLogPalette)+Pred(PalSize)*Sizeof(TPaletteEntry);
GetMem(LogPal,sz);
for i := 0 to Pred(PalSize) do
With LogPal^ do
begin
palNumEntries := PalSize;
palVersion := $0300;
With palPalEntry[i],bmi.bmicolors[i] do
begin
peRed := rgbRed;
peBlue := rgbBlue;
peGreen := rgbGreen;
peFlags := 0;
end;
end;
hPal := CreatePalette(LogPal^);
FreeMem(LogPal,sz);
end;
{ Attempt to open a Windows 3.0 device independent bitmap }
function TBitScrollWindow.OpenDIB(var TheFile: File): Boolean;
var
bitCount: Word;
size: Word;
longWidth: Longint;
DCHandle: HDC;
BitsPtr: Pointer;
BitmapInfo: PBitmapInfo;
BitsHandle, NewBitmapHandle,OldPal: THandle; {!!}
NewPixelWidth, NewPixelHeight: Word;
begin
OpenDIB := True;
Seek(TheFile, 28);
BlockRead(TheFile, bitCount, SizeOf(bitCount));
if bitCount <= 8 then
begin
size := SizeOf(TBitmapInfoHeader) + ((1 shl bitCount) * SizeOf(TRGBQuad));
BitmapInfo := MemAlloc(size);
Seek(TheFile, SizeOf(TBitmapFileHeader));
BlockRead(TheFile, BitmapInfo^, size);
NewPixelWidth := BitmapInfo^.bmiHeader.biWidth;
NewPixelHeight := BitmapInfo^.bmiHeader.biHeight;
CopyDIBPalette(BitMapInfo^);
longWidth := (((NewPixelWidth * bitCount) + 31) div 32) * 4;
BitmapInfo^.bmiHeader.biSizeImage := longWidth * NewPixelHeight;
GlobalCompact(-1);
BitsHandle := GlobalAlloc(gmem_Moveable or gmem_Zeroinit,
BitmapInfo^.bmiHeader.biSizeImage);
GetBitmapData(TheFile, BitsHandle, BitmapInfo^.bmiHeader.biSizeImage);
DCHandle := CreateDC('Display', nil, nil, nil);
BitsPtr := GlobalLock(BitsHandle);
OldPal := SelectPalette(DCHandle,hPal,false); {!!}
UnrealizeObject(hPal); {!!}
RealizePalette(DCHandle); {!!}
NewBitmapHandle :=
CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
BitmapInfo^, 0);
SelectPalette(DCHandle,OldPal,false); {!!}
DeleteDC(DCHandle);
GlobalUnlock(BitsHandle);
GlobalFree(BitsHandle);
FreeMem(BitmapInfo, size);
if NewBitmapHandle <> 0 then
begin
if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
BitmapHandle := NewBitmapHandle;
PixelWidth := NewPixelWidth;
PixelHeight := NewPixelHeight;
end
else
OpenDIB := False;
end
else
OpenDIB := False;
end;
{ Test if the passed file is a Windows 3.0 DI bitmap and if so read it.
Report errors if unable to do so. Adjust the Scroller to the new
bitmap dimensions. }
function TBitScrollWindow.LoadBitmapFile(Name: PChar): Boolean;
var
TheFile: File;
TestWin30Bitmap: Longint;
ErrorMsg: PChar;
OldCursor: HCursor;
begin
ErrorMsg := nil;
OldCursor := SetCursor(LoadCursor(0, idc_Wait));
Assign(TheFile, Name);
{$I-}
Reset(TheFile, 1);
{$I+}
if IOResult = 0 then
begin
Seek(TheFile, 14);
BlockRead(TheFile, TestWin30Bitmap, SizeOf(TestWin30Bitmap));
if TestWin30Bitmap = 40 then
if OpenDIB(TheFile) then
begin
AdjustScroller;
IconImageValid := False;
end
else ErrorMsg := 'Unable to create Windows 3.0 bitmap from file'
else
ErrorMsg := 'Not a Windows 3.0 bitmap file';
Close(TheFile);
end
else
ErrorMsg := 'Cannot open bitmap file';
SetCursor(OldCursor);
if ErrorMsg = nil then LoadBitmapFile := True else
begin
MessageBox(HWindow, ErrorMsg, bsa_Name, mb_Ok);
LoadBitmapFile := False;
end;
end;
{ Responds to an incoming "paint" message by redrawing the bitmap. (The
Scroller's BeginView method, which sets the viewport origin relative
to the present scroll position, has already been called. ) }
procedure TBitScrollWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
MemoryDC: HDC;
OldBitmapHandle: THandle;
OldPal : THandle; {!!}
ClientRect: TRect;
begin
if BitmapHandle <> 0 then
begin
MemoryDC := CreateCompatibleDC(PaintDC);
OldPal := SelectPalette(MemoryDC,hPal,false); {!!}
UnrealizeObject(hPal); {!!}
RealizePalette(MemoryDC); {!!}
if IsIconic(HWindow) then
OldBitmapHandle := SelectObject(MemoryDC, IconizedBits)
else
begin
OldBitmapHandle := SelectObject(MemoryDC, BitmapHandle);
if Mode = srcCopy then
begin
SetBkColor(PaintDC, GetNearestColor(PaintDC, $800000));
SetTextColor(PaintDC, $FFFFFF);
end;
end;
BitBlt(PaintDC, 0, 0, PixelWidth, PixelHeight, MemoryDC, 0, 0,
Mode);
SelectObject(MemoryDC,OLDPal); {!!}
SelectObject(MemoryDC, OldBitmapHandle);
DeleteDC(MemoryDC);
end;
end;
{ Declare a variable of type TBitScrollApp }
var
ScrollApp: TBitScrollApp;
{ Run the BitScrollApp }
begin
ScrollApp.Init(bsa_Name);
ScrollApp.Run;
ScrollApp.Done;
end.